home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / AMIGA / (A)TB / (A)TBF.ADF / FontPrinter / fontprinter1.3 < prev    next >
Text File  |  1989-09-12  |  6KB  |  250 lines
  1. CLEAR ,100000&                         
  2. SCREEN 2,640,400,1,4   
  3. WINDOW 6,"",(50,270)-(580,280),0,2 
  4. PRINT "To quit, hold down the 'Q' key.";  
  5. WINDOW 5,"PROGRAM STATUS",(50,300)-(580,310),0,2                        
  6. WINDOW 3,"FONT NAME AND HEIGHT",(50,330)-(580,340),0,2
  7. WINDOW 4,"FONT COUNT",(50,360)-(580,370),0,2
  8. PRINT "# Fonts Printed:           # Fonts to be printed:";
  9. PALETTE 0,1,1,1                                   
  10. PALETTE 1,0,0,0               
  11.  
  12. DEFLNG a-Z
  13. DECLARE FUNCTION AskSoftStyle() LIBRARY
  14. DECLARE FUNCTION OpenFont() LIBRARY
  15. DECLARE FUNCTION OpenDiskFont() LIBRARY 
  16. DECLARE FUNCTION AllocMem() LIBRARY
  17. DECLARE FUNCTION DoIO% LIBRARY
  18. DECLARE FUNCTION OpenDevice% LIBRARY
  19. DECLARE FUNCTION AllocSignal% LIBRARY
  20. DECLARE FUNCTION FindTask& LIBRARY
  21.  
  22. LIBRARY "graphics.library"
  23. LIBRARY "diskfont.library"
  24. LIBRARY "exec.library"
  25. DIM height%(1000),font$(1000)
  26. DIM StructAddr&(1000),StructValue&(1000),StructSize&(1000)
  27. font$(0) = "Topaz.font":height%(0)=8
  28. numfonts = 1
  29.  
  30. FontMenu:
  31. WINDOW 5
  32. CLS
  33. PRINT "Getting Fonts...";
  34. qt$=INKEY$
  35. IF qt$="Q" OR qt$="q" THEN quit
  36. GOSUB GetFonts
  37. CLS
  38. PRINT "Alphabetizing font names...";
  39. qt$=INKEY$
  40. IF qt$="Q" OR qt$="q" THEN quit
  41. GOSUB FontNameFix
  42. CLS
  43. PRINT "Organizing fonts from smallest to largest...";
  44. qt$=INKEY$
  45. IF qt$="Q" OR qt$="q" THEN quit
  46. GOSUB HeightFix
  47. qt$=INKEY$
  48. IF qt$="Q" OR qt$="q" THEN quit
  49. CLS
  50. PRINT "Printing fonts...";
  51. FOR chrispy = 1 TO numfonts-1
  52. TextAttr&(0) = SADD(font$(chrispy)+CHR$(0))
  53. TextAttr&(1) = 65536&*height%(chrispy)
  54. IF fontname$ = "topaz.font" THEN
  55. fh=OpenFont(VARPTR(TextAttr&(0)))
  56. ELSE
  57. fh = OpenDiskFont(VARPTR(TextAttr&(0)))
  58. END IF
  59. winhgt=height%(chrispy) * 2 + 10
  60. WINDOW 2,"",(0,0)-(617,winhgt),0,2
  61. SetFont WINDOW(8),fh
  62. WINDOW 3
  63. CLS
  64. f1$ = font$(chrispy)
  65. f2$ = LEFT$(f1$,LEN(f1$)-5)
  66. PRINT f2$+" ";height%(chrispy);
  67. hardcopy
  68. WINDOW 2
  69. CLS
  70. PRINT "abcdefghijklmnopqrstuvwxyz1234567890-=\[];',./"
  71. PRINT "ABCDEFGHIJKLMNOPQRSTUVWXYZ!@#$%^&*()_+|{}:<>?";
  72. hardcopy
  73. CloseFont(fh)
  74. WINDOW CLOSE 2
  75. WINDOW OUTPUT 4
  76. LOCATE 1,19:PRINT"   ";:LOCATE 1,19:PRINT chrispy;
  77. LOCATE 1,51:PRINT STR$(numfonts-1-chrispy)+"     ";
  78. qt$=INKEY$
  79. IF qt$="Q" OR qt$="q" THEN quit
  80. NEXT chrispy
  81.  
  82. quit:
  83. WINDOW CLOSE 3
  84. WINDOW CLOSE 4
  85. WINDOW CLOSE 5
  86. WINDOW CLOSE 6
  87. SCREEN CLOSE 2
  88. LIBRARY CLOSE
  89. CLEAR ,25000
  90. END                   
  91.  
  92. GetFonts:
  93. MEMF.CLEAR=2^16 'clear memory block
  94. AF.SIZE=2000 'size of font block
  95. AllFonts=AllocMem(AF.SIZE,MEMF.CLEAR)
  96. IF AllFonts=0 THEN ERROR 7 'not enough memory
  97. 'build list of fonts
  98. AvailFonts AllFonts,AF.SIZE,2
  99. entries%=PEEKW(AllFonts)
  100. 'transfer names and heights to list
  101. FOR i=0 TO entries%-1
  102. entry=AllFonts+4+i*10
  103. fontname=PEEKL(entry)
  104. height=PEEKW(entry+4)
  105. STRCOPY fontname,font1$
  106. IF font1$<>font$(numfonts-1) OR height<>height%(numfonts-1) THEN
  107. font$(numfonts)=font1$
  108. height%(numfonts)=height
  109. numfonts=numfonts+1
  110. END IF
  111. NEXT i
  112. FreeMem AllFonts,AF.SIZE
  113. RETURN
  114.  
  115. SUB STRCOPY(source&,build$) STATIC
  116. c=-1:i=0:build$=""
  117. WHILE c<>0
  118. c=PEEK(source&+i)
  119. IF c>0 THEN build$=build$+CHR$(c)
  120. i=i+1
  121. WEND
  122. END SUB
  123.  
  124. FontNameFix:
  125.   NumberofEntries% = numfonts-1 
  126.   DIM Switched%(20+NumberofEntries%/4) 
  127.   Switched%(1)=1 
  128.   Switched%(2)=NumberofEntries% 
  129.   Pointer%=2 
  130. QSstr1: 
  131.   Last%=Switched%(Pointer%) 
  132.   Pointer%=Pointer%-1 
  133.   first%=Switched%(Pointer%) 
  134.   Pointer%=Pointer%-1 
  135.   LeadIndex%=first% 
  136. QSstr2: 
  137.   TrailIndex%=Last% 
  138.   MidPoint$=font$((first%+Last%)/2) 
  139. QSstr3: 
  140.   IF UCASE$(font$(LeadIndex%))<UCASE$(MidPoint$) THEN 
  141.     LeadIndex%=LeadIndex%+1 
  142.     GOTO QSstr3 
  143.   END IF 
  144. QSstr4: 
  145.   IF UCASE$(font$(TrailIndex%))>UCASE$(MidPoint$) THEN 
  146.     TrailIndex%=TrailIndex%-1 
  147.     GOTO QSstr4 
  148.   END IF 
  149.   IF LeadIndex%<=TrailIndex% THEN 
  150.     temp$=font$(LeadIndex%) 
  151.     font$(LeadIndex%)=font$(TrailIndex%) 
  152.     font$(TrailIndex%)=temp$ 
  153.     temp%=height%(LeadIndex%)
  154.     height%(LeadIndex%)=height%(TrailIndex%)
  155.     height%(TrailIndex%)=temp%
  156.     LeadIndex%=LeadIndex%+1 
  157.     TrailIndex%=TrailIndex%-1 
  158.   END IF 
  159.   IF LeadIndex%<=TrailIndex% THEN QSstr3 
  160.   IF first%<TrailIndex% THEN 
  161.     Pointer%=Pointer%+1 
  162.     Switched%(Pointer%)=first% 
  163.     Pointer%=Pointer%+1 
  164.     Switched%(Pointer%)=TrailIndex% 
  165.   END IF 
  166.   first%=LeadIndex% 
  167.   IF first%<Last% THEN QSstr2 
  168.   IF Pointer%<>0 THEN QSstr1 
  169.   ERASE Switched% 
  170.   RETURN
  171.  
  172. HeightFix:
  173. FOR x = 1 TO numfonts-1
  174. FOR y = x TO numfonts-1
  175. IF height%(y) < height%(x) AND font$(x) = font$(y) THEN
  176. temp% = height%(x)
  177. height%(x) = height%(y)
  178. height%(y) = temp%
  179. END IF
  180. NEXT y
  181. NEXT x
  182. RETURN
  183.  
  184.   
  185. SUB hardcopy STATIC
  186. mem.opt& = 2^0+2^16
  187. p.io& = AllocMem&(100,mem.opt&)
  188. p.port& = p.io&+62
  189. IF p.io& = 0 THEN ERROR 7
  190.  
  191. f.windo& = WINDOW(7)
  192. f.rastport& = PEEKL(f.windo&+50)
  193. f.width% = PEEKW(f.windo&+112)
  194. f.height% = PEEKW(f.windo&+114)
  195. f.screen& = PEEKL(f.windo&+46)
  196. f.viewport& = f.screen&+44
  197. f.colormap& = PEEKL(f.viewport&+4)
  198. f.vp.mode% = PEEKW(f.viewport&+32)
  199.  
  200. p.sigBit% = AllocSignal%(-1)
  201. IF p.sigBit% = -1 THEN
  202. PRINT"No Signalbit free!"
  203. CALL FreeMem(p.io&,100)
  204. EXIT SUB
  205. END IF
  206. p.sigTask& = FindTask&(0)
  207.  
  208. POKE p.port&+8,4
  209. POKEL p.port&+10,p.port&+34
  210. POKE p.port&+15,p.sigBit%
  211. POKEL p.port&+16,p.sigTask&
  212. POKEL p.port&+20,p.port&+24
  213. POKEL p.port&+28,p.port&+20
  214. POKE p.port&+34,ASC("P")
  215. POKE p.port&+35,ASC("R")
  216. POKE p.port&+36,ASC("T")
  217.  
  218. CALL AddPort(p.port&)
  219.  
  220. POKE p.io&+8,5
  221. POKEL p.io&+14,p.port&
  222. POKEW p.io&+28,11
  223. POKEL p.io&+32,f.rastport&
  224. POKEL p.io&+36,f.colormap&
  225. POKEL p.io&+40,f.vp.mode%
  226. POKEW p.io&+48,f.width%
  227. POKEW p.io&+50,f.height%
  228. POKEL p.io&+52,f.width%
  229. POKEL p.io&+56,f.height%
  230. POKEW p.io&+60,4
  231.  
  232. d.name$ = "printer.device"+CHR$(0)
  233. status% =OpenDevice%(SADD(d.name$),0,p.io&,0)
  234. IF status%<>0 THEN
  235. PRINT "Printer is not free."
  236. CALL FreeMem(p.io&,100)
  237. CALL FreeSignal(p.sigBit%)
  238. EXIT SUB
  239. END IF
  240.  
  241. ercond% = DoIO%(p.io&)
  242.  
  243. CALL CloseDevice(p.io&)
  244. CALL RemPort(p.port&)
  245. CALL FreeMem(p.io&,100)
  246. CALL FreeSignal(p.sigBit%)
  247. END SUB
  248.  
  249.  
  250.